home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / oodles-of-utils / mixin-madness / simple-view-mixins / GWorld-svm.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  18.8 KB  |  422 lines  |  [TEXT/CCL2]
  1. (in-package  :oou)
  2. (oou-provide :GWorld-svm)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; GWorld-svm.lisp
  5. ;;
  6. ;; Copyright © 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;         Tamar Offer
  11. ;;
  12. ;; mixin for using GWorlds to draw views
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14.  
  15. (oou-dependencies :simple-view-ce
  16.                   :GWorld-view
  17.                   :QD-fx-u)
  18.  
  19. (export '(GWorld-svm
  20.           GWorld-view
  21.           GW-current-slide GWorld-set-current-slide GWorld-draw-to-slide
  22.           GWorld-slide-to-slide-copy GWorld-screen-to-slide-copy
  23.           GWorld-margins GWorld-slide-size
  24.           GW-copy-mode GW-copy-rgn GW-fore-color GW-back-color
  25.           GW-update-fx GW-slide-fx GW-fx-delay GW-wipe-count
  26.           GW-num-slides
  27.           ))
  28.  
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30.  
  31.  
  32. (defclass GWorld-svm ()
  33.   ((GWorld-view         :accessor GWorld-view
  34.                         :initarg :GWorld-view)
  35.    (GW-init-fn          :initarg :GW-init-fn
  36.                         :accessor GW-init-fn)
  37.    (GW-num-slides       :initarg :GW-num-slides
  38.                         :accessor GW-num-slides)
  39.    (GW-current-slide    :initarg :GW-current-slide
  40.                         :accessor GW-current-slide)
  41.    
  42.    (GW-copy-mode        :initarg :GW-copy-mode
  43.                         :accessor GW-copy-mode)
  44.    (GW-copy-rgn         :initarg :GW-copy-rgn
  45.                         :accessor GW-copy-rgn)
  46.    (GW-fore-color       :initarg :GW-fore-color
  47.                         :accessor GW-fore-color)
  48.    (GW-back-color       :initarg :GW-back-color
  49.                         :accessor GW-back-color)
  50.    
  51.    (GW-update-fx        :initarg :GW-update-fx
  52.                         :accessor GW-update-fx)
  53.    (GW-slide-fx         :initarg :GW-slide-fx
  54.                         :accessor GW-slide-fx)
  55.    (GW-fx-delay         :initarg :GW-fx-delay
  56.                         :accessor GW-fx-delay)
  57.    (GW-wipe-count       :initarg :GW-wipe-count
  58.                         :accessor GW-wipe-count)
  59.    (GW-free-on-remove-p :initarg :GW-free-on-remove-p
  60.                         :accessor GW-free-on-remove-p)
  61.    )
  62.   
  63.   (:default-initargs
  64.     :GW-num-slides       1
  65.     :GW-current-slide    0
  66.     :GW-depth            8
  67.     
  68.     :GW-copy-mode        #$srcCopy
  69.     :GW-copy-rgn         (%null-ptr)
  70.     :GW-fore-color       *black-color*
  71.     :GW-back-color       *white-color*
  72.     
  73.     :GW-update-fx        :none
  74.     :GW-slide-fx         :transporter
  75.     :GW-fx-delay         0
  76.     :GW-wipe-count       8
  77.     :GW-free-on-remove-p t
  78.     ))
  79.  
  80. (defmethod initialize-instance :after ((sv GWorld-svm) &rest initargs &key &allow-other-keys)
  81.   (declare (dynamic-extent initargs))
  82.   (unless (slot-boundp sv 'GWorld-view)
  83.     (setf (GWorld-view sv) (apply #'make-instance 'GWorld-view
  84.                                   :view-size        (GWorld-total-slide-size sv)
  85.                                   :view-position    (GWorld-corners sv)
  86.                                   :allow-other-keys t
  87.                                   initargs))))
  88.  
  89. (defmethod install-view-in-window :after ((sv GWorld-svm) w)
  90.   (declare (ignore w))
  91.   (GWorld-alloc (GWorld-view sv))
  92.   (let ((install-complete nil))
  93.     (unwind-protect
  94.       (progn
  95.         (GWorld-init-slides sv)
  96.         (setf install-complete t))
  97.       (unless install-complete
  98.         (when (GW-free-on-remove-p sv)
  99.           (GWorld-free (GWorld-view sv)))))))
  100.  
  101. (defmethod remove-view-from-window :after ((sv GWorld-svm))
  102.   (when (GW-free-on-remove-p sv)
  103.     (GWorld-free (GWorld-view sv))))
  104.  
  105. (defmethod view-draw-contents ((sv GWorld-svm))
  106.   (GWorld-show-current-slide sv (GW-update-fx sv)))
  107.  
  108. (defmethod set-view-size :after ((sv GWorld-svm) h &optional v)
  109.   (declare (ignore h v))
  110.   (set-view-size (GWorld-view sv) (GWorld-total-slide-size sv))
  111.   (GWorld-update sv)
  112.   (erase-view sv))
  113.  
  114. (defmethod (setf GW-num-slides) :after (num-slides (sv GWorld-svm))
  115.   (declare (ignore num-slides))
  116.   (set-view-size (GWorld-view sv) (GWorld-total-slide-size sv))
  117.   (GWorld-update sv))
  118.  
  119. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  120.  
  121. (eval-when (:compile-toplevel :load-toplevel :execute)
  122.   
  123.   (defmacro with-GW-slide ((sv slide-num) &body body)
  124.     (let ((cur-origin (gensym)))
  125.       `(let ((,cur-origin (view-origin (GWorld-view ,sv))))
  126.          (GWorld-set-origin (GWorld-view ,sv) (GWorld-slide-origin ,sv ,slide-num))
  127.          (unwind-protect
  128.            (progn ,@body)
  129.            (GWorld-set-origin (GWorld-view ,sv) ,cur-origin)))))
  130.  
  131.   (defmacro with-locked-GW-slide ((sv slide-num) &body body)
  132.     `(with-GW-slide (,sv ,slide-num)
  133.        (with-locked-GWorld-view (GWorld-view ,sv)
  134.          ,@body)))
  135.  
  136.   (defmacro with-focused-GW-slide ((sv slide-num) &body body)
  137.     `(with-GW-slide (,sv ,slide-num)
  138.        (with-focused-view (GWorld-view ,sv)
  139.          ,@body)))
  140.  
  141.   )
  142.  
  143. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  144.  
  145.  
  146. (defmethod GWorld-margins ((sv GWorld-svm))
  147.   (declare (ignore sv))
  148.   (values #@(0 0) #@(0 0)))
  149.  
  150. (defmethod GWorld-corners ((sv GWorld-svm))
  151.   (multiple-value-bind (topLeft botRight) (focused-corners sv)
  152.     (multiple-value-bind (tl-margin br-margin) (GWorld-margins sv)
  153.       (values (add-points topLeft tl-margin) (subtract-points botRight br-margin)))))
  154.  
  155. (defmethod GWorld-slide-size ((sv GWorld-svm))
  156.   (multiple-value-bind (topLeft botRight) (GWorld-corners sv)
  157.     (subtract-points botRight topLeft)))
  158.  
  159. (defmethod GWorld-total-slide-size ((sv GWorld-svm))
  160.   (let ((slide-size (GWorld-slide-size sv)))
  161.     (make-point (point-h slide-size)
  162.                 (* (GW-num-slides sv) (point-v slide-size)))))
  163.  
  164. (defmethod GWorld-init-slides ((sv GWorld-svm))
  165.   (when (slot-boundp sv 'GW-init-fn)
  166.     (dotimes (i (GW-num-slides sv))
  167.       (GWorld-draw-to-slide sv i (GW-init-fn sv)))))
  168.  
  169. (defmethod GWorld-update ((sv GWorld-svm))
  170.   (GWorld-realloc (GWorld-view sv))
  171.   (GWorld-init-slides sv)
  172.   (invalidate-view sv nil))
  173.  
  174. ;;Returns the GWorld origin to use to put the topLeft of the slide at #@(0 0)
  175. (defmethod GWorld-slide-origin ((sv GWorld-svm) slide-num)
  176.   (make-point 0 (* -1 slide-num (point-v (GWorld-slide-size sv)))))
  177.  
  178.  
  179. (defmethod GWorld-set-current-slide ((sv GWorld-svm) slide-num &key (inval-p nil) (draw-now-p t))
  180.   (when slide-num
  181.     (unless (and (>= slide-num 0) (< slide-num (GW-num-slides sv)))
  182.       (error "slide number, ~a, out of bounds [~a-~a]." slide-num 0 (GW-num-slides sv))))
  183.   (setf (GW-current-slide sv) slide-num)
  184.   (when inval-p (invalidate-view sv (not slide-num)))
  185.   (when draw-now-p
  186.     (with-focused-view (focusing-view sv)
  187.       (if slide-num
  188.         (GWorld-show-current-slide sv (GW-slide-fx sv))
  189.         (multiple-value-bind (topLeft botRight) (GWorld-corners sv)
  190.           (rlet ((r :Rect :topLeft topLeft :botRight botRight))
  191.             (#_EraseRect r)))))))
  192.       
  193.    
  194. (defmethod GWorld-draw-to-slide ((sv GWorld-svm) slide-num draw-fn)
  195.   (with-focused-GW-slide (sv slide-num)
  196.     (funcall draw-fn sv slide-num (GWorld (GWorld-view sv)))))
  197.  
  198.  
  199. (defmethod GWorld-slide-to-slide-copy ((sv GWorld-svm) from-slide-num to-slide-num
  200.                                        &key
  201.                                        (from-rect nil)
  202.                                        (to-rect   nil)
  203.                                        (copy-mode #$srcCopy)
  204.                                        (copy-rgn  (%null-ptr))
  205.                                        (fore-color *black-color*)
  206.                                        (back-color *white-color*))
  207.   (rlet ((f-rect :Rect
  208.                  :topLeft  (if from-rect (pref from-rect :Rect.topLeft)  #@(0 0))
  209.                  :botRight (if from-rect (pref from-rect :Rect.botRight) (GWorld-slide-size sv)))
  210.          (t-rect :Rect
  211.                  :topLeft  (if to-rect (pref to-rect :Rect.topLeft)  #@(0 0))
  212.                  :botRight (if to-rect (pref to-rect :Rect.botRight) (GWorld-slide-size sv))))
  213.     (#_OffsetRect :pointer f-rect :long (subtract-points (GWorld-slide-origin sv to-slide-num)
  214.                                                          (GWorld-slide-origin sv from-slide-num)))
  215.     (with-focused-GW-slide (sv to-slide-num)
  216.       (with-fore-color fore-color
  217.         (with-back-color back-color
  218.           (#_CopyBits (view-portBits (GWorld-view sv)) (view-portBits (GWorld-view sv)) f-rect t-rect copy-mode copy-rgn))))))
  219.  
  220.  
  221. (defmethod GWorld-screen-to-slide-copy ((sv GWorld-svm) slide-num
  222.                                         &key
  223.                                         (from-rect nil)
  224.                                         (to-rect   nil)
  225.                                         (copy-mode #$srcCopy)
  226.                                         (copy-rgn  (%null-ptr))
  227.                                         (fore-color *black-color*)
  228.                                         (back-color *white-color*))
  229.   (multiple-value-bind (topLeft botRight) (GWorld-corners sv)
  230.     (rlet ((f-rect :Rect
  231.                    :topLeft  (if from-rect (pref from-rect :Rect.topLeft)  topLeft)
  232.                    :botRight (if from-rect (pref from-rect :Rect.botRight) botRight))
  233.            (t-rect :Rect
  234.                    :topLeft  (if to-rect (pref to-rect :Rect.topLeft)  #@(0 0))
  235.                    :botRight (if to-rect (pref to-rect :Rect.botRight) (GWorld-slide-size sv))))
  236.       (with-focused-view (focusing-view sv)
  237.         (with-focused-GW-slide (sv slide-num)
  238.           (with-fore-color fore-color
  239.             (with-back-color back-color
  240.                 (#_CopyBits (view-portBits sv) (view-portBits (GWorld-view sv)) f-rect t-rect copy-mode copy-rgn))))))))
  241.  
  242.  
  243. ;;copies the specified slide on screen using the specified effect
  244. ;;Note: assumes it's already focused on the proper view
  245. (defmethod GWorld-show-current-slide ((sv GWorld-svm) fx-key)
  246.   (when (GW-current-slide sv)
  247.     (multiple-value-bind (topLeft botRight) (GWorld-corners sv)
  248.       (rlet ((win-rect :Rect :topLeft topLeft :botRight botRight)
  249.              (gw-rect  :Rect :topLeft #@(0 0) :botRight (GWorld-slide-size sv)))
  250.         (with-fore-color (GW-fore-color sv)
  251.           (with-back-color (GW-back-color sv)
  252.             (with-locked-GW-slide (sv (GW-current-slide sv))
  253.               (with-macptrs ((gw-portBits (view-portBits (GWorld-view sv))))
  254.                 (ecase fx-key
  255.                   (:none (with-current-portBits win-portBits
  256.                            (#_CopyBits gw-portBits win-portBits gw-rect win-rect (GW-copy-mode sv) (GW-copy-rgn sv))))
  257.                   ((:transporter :waynes-world :screen-door :v-blind :h-blind)
  258.                    (dissolve-o-rama gw-portBits gw-rect win-rect
  259.                                     :copy-mode    (GW-copy-mode sv)
  260.                                     :copy-rgn     (GW-copy-rgn sv)
  261.                                     :delay-ticks  (GW-fx-delay sv)
  262.                                     :dissolve-type fx-key))
  263.                   ((:left-to-right :right-to-left :top-to-bottom :bottom-to-top)
  264.                    (wipe-o-rama gw-portBits gw-rect win-rect
  265.                                 :copy-mode      (GW-copy-mode sv)
  266.                                 :copy-rgn       (GW-copy-rgn sv)
  267.                                 :delay-ticks    (GW-fx-delay sv)
  268.                                 :wipe-count     (GW-wipe-count sv)
  269.                                 :wipe-direction fx-key))
  270.                   ((:round-iris-in :round-iris-out)
  271.                    (iris-o-rama gw-portBits gw-rect win-rect
  272.                                 :copy-mode      (GW-copy-mode sv)
  273.                                 :copy-rgn       (GW-copy-rgn sv)
  274.                                 :delay-ticks    (GW-fx-delay sv)
  275.                                 :iris-direction (ecase fx-key
  276.                                                   (:round-iris-out :outward)
  277.                                                   (:round-iris-in  :inward))
  278.                                 :iris-shape     :round))
  279.                   ((:square-iris-in :square-iris-out)
  280.                    (iris-o-rama gw-portBits gw-rect win-rect
  281.                                 :copy-mode      (GW-copy-mode sv)
  282.                                 :copy-rgn       (GW-copy-rgn sv)
  283.                                 :delay-ticks    (GW-fx-delay sv)
  284.                                 :iris-direction (ecase fx-key
  285.                                                   (:square-iris-out :outward)
  286.                                                   (:square-iris-in  :inward))
  287.                                 :iris-shape     :square))
  288.                   )))))))))
  289.  
  290. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  291.  
  292. #|
  293.  
  294. (oou-dependencies :PICT-u
  295.                   :back-PICT)
  296.  
  297. (defclass off-screen-view (GWorld-svm view) ())
  298. (defvar *test-w*)
  299. (defparameter *xport-coordinates* #@(198 144))
  300. (defparameter *xport-dimensions* #@(59 182))
  301.  
  302. (defun off-init (sv frame-num gw)
  303.   (declare (ignore gw))
  304.   (case frame-num
  305.     (0 
  306.      (rlet ((r :Rect :topLeft (subtract-points #@(0 0) *xport-coordinates*)))
  307.        (with-back-color (make-color -1 0 -1) (#_EraseRect r))
  308.        (draw-picture-from-file "oou:examples;columns.PICT"  r nil)
  309.        ))
  310.     (1 
  311.      (rlet ((r :Rect :topLeft #@(0 0) :botRight (GWorld-slide-size sv)))
  312.        (with-back-color (make-color -1 0 -1) (#_EraseRect r))
  313.        (draw-picture-from-file "oou:examples;kirk.PICT" r nil)))))
  314.  
  315. (defun beam (in-p)
  316.   (GWorld-set-current-slide (view-named :off *test-w*) (if in-p 1 0)))
  317.  
  318. (defun off-fx (fx)
  319.   (setf (GW-slide-fx (view-named :off *test-w*)) fx))
  320.  
  321. (defun delay-set (ticks)
  322.   (setf (GW-fx-delay (view-named :off *test-w*)) ticks))
  323.  
  324. ;view this window on a color monitor
  325. (setf *test-w*
  326.       (make-instance
  327.         'back-PICT-window
  328.         :window-type :document
  329.         :window-title "Transporter Demo"
  330.         :color-p t
  331.         :view-size #@(465 400)
  332.         :PICT-file "oou:examples;columns.PICT"
  333.         :PICT-scaling :adjust-view-size
  334.         :PICT-storage :disk
  335.         :view-subviews
  336.         (list (make-instance 'off-screen-view
  337.                 :view-position   *xport-coordinates*
  338.                 :view-size       *xport-dimensions*
  339.                 :view-nick-name  :off
  340.                 :GW-depth         8
  341.                 :GW-num-slides    2
  342.                 :GW-current-slide 0
  343.                 :GW-back-color    (make-color #xFFFF 0 #xFFFF)
  344.                 :GW-copy-mode     (+ #$patCopy #$transparent)
  345.                 :GW-init-fn       'off-init)
  346.               (make-instance 'button-dialog-item
  347.                 :dialog-item-text "Beam me down"
  348.                 :view-font '("Geneva" 0)
  349.                 :view-position #@(5 5)
  350.                 :dialog-item-action #'(lambda (di) (declare (ignore di)) (beam t)))
  351.               (make-instance 'button-dialog-item
  352.                 :dialog-item-text "Beam me up"
  353.                 :view-font '("Geneva" 0)
  354.                 :view-position #@(110 5)
  355.                 :dialog-item-action #'(lambda (di) (declare (ignore di)) (beam nil)))
  356.               (make-instance 'pop-up-menu
  357.                 :dialog-item-text ""
  358.                 :view-position #@(200 5)
  359.                 :view-size #@(120 20)
  360.                 :menu-items (list (make-instance 'menu-item
  361.                                     :menu-item-title "transporter"
  362.                                     :menu-item-action #'(lambda () (off-fx :transporter)))
  363.                                   (make-instance 'menu-item
  364.                                     :menu-item-title "Wayne's World"
  365.                                     :menu-item-action #'(lambda () (off-fx :waynes-world)))
  366.                                   (make-instance 'menu-item
  367.                                     :menu-item-title "screen door"
  368.                                     :menu-item-action #'(lambda () (off-fx :screen-door)))
  369.                                   (make-instance 'menu-item
  370.                                     :menu-item-title "h-blind"
  371.                                     :menu-item-action #'(lambda () (off-fx :h-blind)))
  372.                                   (make-instance 'menu-item
  373.                                     :menu-item-title "v-blind"
  374.                                     :menu-item-action #'(lambda () (off-fx :v-blind)))
  375.                                   (make-instance 'menu-item
  376.                                     :menu-item-title "l-to-r"
  377.                                     :menu-item-action #'(lambda () (off-fx :left-to-right)))
  378.                                   (make-instance 'menu-item
  379.                                     :menu-item-title "r-to-l"
  380.                                     :menu-item-action #'(lambda () (off-fx :right-to-left)))
  381.                                   (make-instance 'menu-item
  382.                                     :menu-item-title "t-to-b"
  383.                                     :menu-item-action #'(lambda () (off-fx :top-to-bottom)))
  384.                                   (make-instance 'menu-item
  385.                                     :menu-item-title "b-to-t"
  386.                                     :menu-item-action #'(lambda () (off-fx :bottom-to-top)))
  387.                                   (make-instance 'menu-item
  388.                                     :menu-item-title "round iris out"
  389.                                     :menu-item-action #'(lambda () (off-fx :round-iris-out)))
  390.                                   (make-instance 'menu-item
  391.                                     :menu-item-title "round iris in"
  392.                                     :menu-item-action #'(lambda () (off-fx :round-iris-in)))
  393.                                   (make-instance 'menu-item
  394.                                     :menu-item-title "square iris in"
  395.                                     :menu-item-action #'(lambda () (off-fx :square-iris-in)))
  396.                                   (make-instance 'menu-item
  397.                                     :menu-item-title "square iris out"
  398.                                     :menu-item-action #'(lambda () (off-fx :square-iris-out)))
  399.                                   (make-instance 'menu-item
  400.                                     :menu-item-title "none"
  401.                                     :menu-item-action #'(lambda () (off-fx :none)))
  402.                                   ))
  403.               (make-instance 'pop-up-menu
  404.                 :view-position #@(325 5)
  405.                 :view-size #@(120 20)
  406.                 :dialog-item-text ""
  407.                 :menu-items (list (make-instance 'menu-item
  408.                                     :menu-item-title "no delay"
  409.                                     :menu-item-action #'(lambda () (delay-set 0)))
  410.                                   (make-instance 'menu-item
  411.                                     :menu-item-title "2 ticks"
  412.                                     :menu-item-action #'(lambda () (delay-set 2)))
  413.                                   (make-instance 'menu-item
  414.                                     :menu-item-title "5 ticks"
  415.                                     :menu-item-action #'(lambda () (delay-set 5)))
  416.                                   (make-instance 'menu-item
  417.                                     :menu-item-title "10 ticks"
  418.                                     :menu-item-action #'(lambda () (delay-set 10)))))
  419.               )))
  420.  
  421.  
  422. |#